      SUBROUTINE VpqmnVmnrs_to_Vpqrs_large_g(Vpqmn, Vmnrs, SYMV1, SYMV2,
     &                POPM, POPN,iopmn, POPP, POPQ,ioppq, POPR,POPS,
     &                ioprs, Vpqrs, SYMV3, FACT,fact2, Vpqmnc)
C This program is to calculate
C Vpqrs=fact2*Vpqrs + fact*V1(mnpq)*V2(mn,rs). 
C with V2(pqmn) be very large like IABCD
C
C---if iopmn = 0, m<n,  else m,n      
C---if ioppq = 0, p<q,  else p,q
C---if ioprs = 0, r<s,  else r,s
C
      use mod_orbit
      use mod_symm
      use mod_iop
      IMPLICIT NONE 
C
      INTEGER, intent(in) :: SYMV1, SYMV2, SYMV3
      INTEGER, intent(in) :: IOPpq, iopmn, ioprs
      INTEGER, intent(in) :: POPP(8),POPQ(8),POPR(8)
      INTEGER, intent(in) :: POPS(8),POPM(8),POPN(8)
      real*4, intent(inout) :: Vpqmn(*)
      real*4, intent(inout) :: Vpqmnc(*)
      real*4, intent(inout) :: Vpqrs(*), Vmnrs(*)
      real*8, intent(in) :: FACT, fact2
      real*8 :: tt1, tt2, rt1, rt2, copytime, readtime,calctime
C
      real*4 test
      INTEGER INUMPQ(8), INUMRS(8), INUMMN(8)
      INTEGER IABSOFF1(8), IABSOFF3(8), IABSOFF2(8)
      INTEGER IRR, IRR1, IRR2, iopv1, iopv2, iopv3
      INTEGER IRREPR, IRREPL, IRREP
      INTEGER IRREPPQ, IRREPRS, IRREPMN 
      INTEGER IRREPP, IRREPQ, IRREPR1, IRREPS1, IRREPM, IRREPN
      INTEGER NUML, NUMR, IOFFV1, IOFFV2, IOFFV3
      INTEGER IOFFCHECK2(8), IOFFCHECK3(8) 
      INTEGER NSIZE, nump, numq, numr1, nums, numm
      INTEGER numn, n, iopf, nummn, numpq, numrs
      INTEGER nfirst, v3start,  nread 
      INTEGER MEMSIZE, nread8
      INTEGER USIZE
      integer  nleft, nsizev2, nsizev3, istat
      INTEGER, EXTERNAL :: IDSYMSOC, irpdso, isymoffso 
      real*8, external::nrm2so
C
      if(fact2/=0.d0.and.fact2/=1.d0) then 
         write(6,*)'error in VpqmnVmnrs_large'
         stop
      endif
      nsize = idsymsoc(symv3, popp, popq, ioppq, popr, pops, ioprs)
      if(fact2==0.d0) then 
         call zeroso(Vpqrs, nsize)
      endif
      USIZE = 1024
      MEMSIZE = USIZE*USIZE*USIZE*4/8 !3GB
      nsizev2 = idsymsoc(symv2, popm, popn, iopmn, popr, pops, ioprs)
      nsizev3 = idsymsoc(symv3, popp, popq, ioppq, popr, pops, ioprs)
C
C compute size of pq and rm for each irrep 
C
      iopv2 = 1; iopv3 = 1
      CALL IZERO(INUMPQ,8); CALL IZERO(INUMRS,8)
      CALL IZERO(INUMMN,8)
C-----inumpq
      do irrep=1, nirrep
         inumpq(irrep) = irpdso(irrep, popp, popq, ioppq) 
      enddo
C-----inumrs
      do irrep=1, nirrep
         inumrs(irrep) = irpdso(irrep, popr, pops, ioprs) 
      enddo
C-----inummn
      do irrep=1, nirrep
         inummn(irrep) = irpdso(irrep, popm, popn, iopmn) 
      enddo
C compute absolute offsets to beginning of each irrep 
C---for Vpqmn
      IABSOFF1(1) = 1
      DO IRREPR = 1, NIRREP-1
         IRREPL = DIRPRD(IRREPR, SYMV1)
         IABSOFF1(IRREPR+1) = IABSOFF1(IRREPR)
     &                      +INUMPQ(IRREPL)*INUMMN(IRREPR)*ISD
      ENDDO
C---for Vmnrs
      IABSOFF2(1) = 1
      DO IRREPR = 1, NIRREP-1
         IRREPL = DIRPRD(IRREPR, SYMV2)
         IABSOFF2(IRREPR+1) = IABSOFF2(IRREPR)
     &                      +INUMMN(IRREPL)*INUMRS(IRREPR)*ISD
      ENDDO
C---for Vpqrs
      IABSOFF3(1) = 1
      DO IRREPR = 1, NIRREP-1
         IRREPL = DIRPRD(IRREPR, SYMV3)
         IABSOFF3(IRREPR+1) = IABSOFF3(IRREPR)
     &                      +INUMPQ(IRREPL)*INUMRS(IRREPR)*ISD
      ENDDO
C
      copytime = 0.d0
      DO IRREPRS = 1, NIRREP 
         IRREPPQ = DIRPRD(IRREPRS, SYMV3) 
         IRREPMN = DIRPRD(IRREPPQ, SYMV1)
         NUMPQ = IRPDSO(IRREPPQ, POPP, POPQ, IOPPQ) 
         NUMRS = IRPDSO(IRREPRS, POPR, POPS, IOPRS) 
         NUMMN = IRPDSO(IRREPMN, POPM, POPN, IOPMN)
         IOFFV1 = IABSOFF1(IRREPMN)  
         IOFFV2 = IABSOFF2(IRREPRS)  
         IOFFV3 = IABSOFF3(IRREPRS)
         NFIRST = 1
         NLEFT = NUMMN
         NREAD = MEMSIZE/NUMPQ
         DO 
            IF(NREAD>NUMMN) NREAD=NUMMN
            if(nleft==0) exit
              call walltimeso(rt1)
              call myicopy_g(Vpqmnc(ioffv1),Vpqmn, numpq*nread)
!              write(6,*)'norm of abcd_uhf', nrm2so(nread*numpq, vpqmn,1)
              call walltimeso(rt2)
              copytime = copytime + rt2-rt1
!               write(6,"(A,i8,i8,i8,i8)")'ioffv3', ioffv3, nfirst, nread, numrs
              call walltimeso(rt1)
!               write(6,*)'nfirst', ioffv1, ioffv2, ioffv3
                call xgemmso('N','N', numpq, numrs,
     &           nread, fact, Vpqmn, numpq, Vmnrs(ioffv2+(nfirst-1)*isd), 
     &           nummn, 1.d0, Vpqrs(ioffv3),numpq)
                ioffv1 = ioffv1 + nread*numpq*isd
                nleft =  nleft - nread 
                nfirst = nfirst+ nread
              call walltimeso(rt2)
              calctime = calctime + rt2-rt1
                if(nread>nleft) nread = nleft
         ENDDO     
      ENDDO
      if(ldebug) then 
      write(6,*)'read time in abcd large cpu', copytime
      write(6,*)'calc time in abcd large cpu', calctime
      endif
C
      RETURN
      END  



















 
